home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0187.ZIP / AMAZING.PAS < prev    next >
Pascal/Delphi Source File  |  1984-09-14  |  9KB  |  293 lines
  1. {  (c) 1984 by Neil J. Rubenking   }
  2. program Amazing;
  3. type
  4.   ColumnType = 1..80;
  5.   regpack = record
  6.               ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
  7.             end;
  8. var
  9.   StopNow          : boolean;
  10.   StCol, EndCol    : ColumnType;
  11.   StRow, EndRow    : 1..24;
  12.   BlankChance      : 1..120;
  13.   Ex               : array[1..42] of char;
  14.   ThisRow, LastRow : array[1..80] of char;
  15.   N, M, ScreenSeg  : integer;
  16.   attribute        : byte;
  17.   OneUp, OneLeft, OneDown, OneRight,
  18.     TwoUp, TwoLeft, TwoDown, TwoRight,
  19.     NoUp, NoLeft, NoDown, NoRight : set of char;
  20. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  21. function Escape: boolean;
  22. var
  23.   C, D : char;
  24. begin
  25.   D := chr(0);
  26.   if keypressed then read(Kbd,C);
  27.   if keypressed then read(Kbd,D);
  28.   if (C = chr(27)) and (D = chr(0)) then Escape := true
  29.     else Escape := false;
  30. end;
  31. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  32. function FindColor:byte;
  33.   var
  34.     ranfor, ranbak : byte;
  35.   begin
  36.     ranfor := random(16);
  37.     repeat
  38.       ranbak := random(8)
  39.     until ranbak <> ranfor;
  40.     FindColor := (ranbak shl 4) or ranfor;
  41.   end;
  42. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  43. function ReadScreen(col,row:byte):char;
  44. var
  45.   LocationCode : integer;
  46.   begin
  47.     LocationCode := (col-1)*2 + (row-1)*160;
  48.     ReadScreen   := chr(Mem[ScreenSeg:LocationCode]);
  49.   end;
  50. {============================================================================}
  51. procedure WriteScrn(col, row: byte; thisChar:char);
  52. var
  53.   LocationCode : integer;
  54. begin
  55.   LocationCode := (col-1)*2 + (row-1)*160;
  56.   Mem[ScreenSeg:locationCode] := ord(ThisChar);
  57.   Mem[ScreenSeg:LocationCode+1] := attribute;
  58. end;
  59. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  60. procedure initialize;
  61.   begin
  62.   StCol       := 0;
  63.   EndCol      := 0;
  64.   StRow       := 0;
  65.   EndRow      := 0;
  66.   BlankChance := 0;
  67.    IF (Mem[0000:1040] AND 48) <> 48 THEN ScreenSeg := $B800
  68.    ELSE ScreenSeg := $B000;
  69.   attribute := 15;
  70.   randomize;
  71.   repeat
  72.     GotoXY(5,5);
  73.     Write('Starting column (1-79):');
  74.     GotoXY(7,6);
  75.     Write('Ending column (1-79):');
  76.     GotoXY(29,5); Read(StCol);
  77.     GotoXY(29,6); Read(EndCol);
  78.     until (StCol>0) and (EndCol>StCol) and (EndCol<80);
  79.   WriteLn;
  80.   repeat
  81.     GotoXY(8,8);
  82.     Write('Starting row (1-24):');
  83.     GotoXY(10,9);
  84.     Write('Ending row (1-24):');
  85.     GotoXY(29,8); Read(StRow);
  86.     GotoXY(29,9); Read(EndRow);
  87.     until (StRow>0) and (EndRow>StRow) and (EndRow<25);
  88.   WriteLn;
  89.   repeat
  90.     WriteLn('Enter # of blanks in character list.  (1-120)');
  91.     read(BlankChance);
  92.     until (BlankChance>0) and (BlankChance<121);
  93.   ClrScr;
  94.   for N := 1 to 40 do Ex[N] := chr(178 + N);
  95.   for N := 1 to BlankChance do Ex[40 + N] := ' ';
  96.   OneUp    := [Ex[ 1],Ex[ 2],Ex[ 3],Ex[12],Ex[14],Ex[15],Ex[17],Ex[19],
  97.               Ex[20],Ex[29],Ex[34],Ex[38],Ex[39]];
  98.   OneLeft  := [Ex[ 2],Ex[ 4],Ex[ 5],Ex[11],Ex[13],Ex[15],Ex[16],Ex[18],
  99.               Ex[19],Ex[30],Ex[32],Ex[37],Ex[39]];
  100.   OneDown  := [Ex[ 1],Ex[ 2],Ex[ 3],Ex[ 6],Ex[13],Ex[16],Ex[17],Ex[19],
  101.               Ex[20],Ex[31],Ex[35],Ex[38],Ex[40]];
  102.   OneRight := [Ex[14],Ex[15],Ex[16],Ex[17],Ex[18],Ex[19],Ex[21],Ex[30],
  103.               Ex[32],Ex[33],Ex[36],Ex[37],Ex[40]];
  104.   TwoUp    := [Ex[ 4],Ex[ 7],Ex[ 8],Ex[10],Ex[11],Ex[21],Ex[22],Ex[24],
  105.               Ex[26],Ex[28],Ex[30],Ex[33],Ex[37]];
  106.   TwoLeft  := [Ex[ 3],Ex[ 6],Ex[ 7],Ex[ 9],Ex[10],Ex[12],Ex[24],Ex[25],
  107.               Ex[27],Ex[28],Ex[29],Ex[31],Ex[38]];
  108.   TwoDown  := [Ex[ 4],Ex[ 5],Ex[ 7],Ex[ 8],Ex[ 9],Ex[21],Ex[23],Ex[25],
  109.               Ex[26],Ex[28],Ex[32],Ex[36],Ex[37]];
  110.   TwoRight := [Ex[20],Ex[22],Ex[23],Ex[24],Ex[25],Ex[26],Ex[27],Ex[28],
  111.               Ex[29],Ex[31],Ex[34],Ex[35],Ex[38]];
  112.   NoUp     := [Ex[ 5],Ex[ 6],Ex[ 9],Ex[13],Ex[16],Ex[18],Ex[23],Ex[25],
  113.               Ex[27],Ex[31],Ex[32],Ex[35],Ex[36],Ex[40],Ex[41]];
  114.   NoLeft   := [Ex[ 1],Ex[ 8],Ex[14],Ex[17],Ex[20],Ex[21],Ex[22],Ex[23],
  115.               Ex[26],Ex[33],Ex[34],Ex[35],Ex[36],Ex[40],Ex[41]];
  116.   NoDown   := [Ex[10],Ex[11],Ex[12],Ex[14],Ex[15],Ex[18],Ex[22],Ex[24],
  117.               Ex[27],Ex[29],Ex[30],Ex[33],Ex[34],Ex[39],Ex[41]];
  118.   NoRight  := [Ex[ 1],Ex[ 2],Ex[ 3],Ex[ 4],Ex[ 5],Ex[ 6],Ex[ 7],Ex[ 8],
  119.               Ex[ 9],Ex[10],Ex[11],Ex[12],Ex[13],Ex[39],Ex[41]];
  120.   for N := StCol to EndCol do LastRow[N] := ' ';
  121.   end;  {procedure initialize}
  122. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  123.    function ValidNeighbour(Nabe:char; P:ColumnType):char;
  124.    var
  125.      XX : char;
  126.      YY : 1..80;
  127.      begin
  128.      if Nabe in OneRight then
  129.        begin
  130.        if LastRow[P] in OneDown then
  131.          begin
  132.          repeat
  133.            XX := Ex[random(40)+1]
  134.          until (XX in OneUp) and (XX in OneLeft)
  135.          end;
  136.        if LastRow[P] in TwoDown then
  137.          begin
  138.          repeat
  139.          XX := Ex[random(40)+1]
  140.          until (XX in TwoUp) and (XX in OneLeft)
  141.          end;
  142.        if LastRow[P] in NoDown then
  143.          begin
  144.          repeat
  145.          XX := Ex[random(40)+1]
  146.          until (XX in NoUp) and (XX in OneLeft)
  147.          end;
  148.        end;    {if Nabe in OneRight}
  149.      if Nabe in TwoRight then
  150.        begin
  151.        if LastRow[P] in OneDown then
  152.          begin
  153.          repeat
  154.          XX := Ex[random(40)+1]
  155.          until (XX in OneUp) and (XX in TwoLeft)
  156.          end;
  157.        if LastRow[P] in TwoDown then
  158.          begin
  159.          repeat
  160.          XX := Ex[random(40)+1]
  161.          until (XX in TwoUp) and (XX in TwoLeft)
  162.          end;
  163.        if LastRow[P] in NoDown then
  164.          begin
  165.          repeat
  166.          XX := Ex[random(40)+1]
  167.          until (XX in NoUp) and (XX in TwoLeft)
  168.          end;
  169.        end;  {if Nabe in TwoRight}
  170.      if Nabe in NoRight then
  171.        begin
  172.        if LastRow[P] in OneDown then
  173.          begin
  174.          repeat
  175.          XX := Ex[random(40)+1]
  176.          until (XX in OneUp) and (XX in NoLeft)
  177.          end;
  178.        if LastRow[P] in TwoDown then
  179.          begin
  180.          repeat
  181.          XX := Ex[random(40)+1]
  182.          until (XX in TwoUp) and (XX in NoLeft)
  183.          end;
  184.        if LastRow[P] in NoDown then
  185.          begin
  186.          repeat
  187.          YY := random(40+BlankChance)+1;
  188.          if YY <= 41 then
  189.            XX := Ex[YY]
  190.            else XX := ' ';
  191.          until (XX in NoUp) and (XX in NoLeft)
  192.          end;
  193.        end;   {if Nabe in NoRight}
  194.        ValidNeighbour := XX;
  195.      end;  {function ValidNeighbour}
  196. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  197. procedure MostRows;
  198. var
  199.   ThisChar : char;
  200.   {--------------------------------------------}
  201.   procedure LastOne;
  202.     begin
  203.       repeat
  204.       ThisRow[EndCol] := ValidNeighbour(ThisRow[EndCol-1],EndCol)
  205.       until ThisRow[EndCol] in NoRight;
  206.     end;
  207.   {--------------------------------------------}
  208.   begin  {main procedure MostRows}
  209.     if ScreenSeg = $B800 then
  210.       if random(10) mod 10 = 0 then
  211.         attribute := findcolor;
  212.     ThisRow[StCol] := ValidNeighbour(Ex[41],StCol);
  213.     writeScrn(StCol,M,ThisRow[StCol]);
  214.     for N := StCol+1 to EndCol-1 do
  215.       begin
  216.       ThisRow[N] := ValidNeighbour(ThisRow[N-1],N);
  217.       WriteScrn(N,M,ThisRow[N]);
  218.       end;
  219.     LastOne;
  220.     WriteScrn(EndCol,M,ThisRow[EndCol]);
  221.     LastRow := ThisRow;
  222.   end;
  223. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  224. procedure FinalRow;
  225. var
  226.   counter : byte;
  227.   begin
  228.     repeat
  229.       ThisRow[StCol] := ValidNeighbour(Ex[41],StCol)
  230.       until ThisRow[StCol] in NoDown;
  231.     writeScrn(StCol,EndRow,ThisRow[StCol]);
  232.     for N := StCol+1 to EndCol-1 do
  233.       begin
  234.       repeat
  235.         ThisRow[N] := ValidNeighbour(ThisRow[N-1],N)
  236.         until ThisRow[N] in NoDown;
  237.       WriteScrn(N,EndRow,ThisRow[N]);
  238.       end;
  239.     counter := 0;
  240.     repeat
  241.       ThisRow[EndCol] := ValidNeighbour(ThisRow[EndCol-1],EndCol);
  242.       counter := counter + 1;
  243.       until ((ThisRow[EndCol] in NoDown) and (ThisRow[EndCol] in NoRight))
  244.           or (counter = 100);
  245.     if counter = 100 then ThisRow[EndCol] := Ex[41];
  246.     WriteScrn(EndCol,EndRow,ThisRow[EndCol]);
  247. end;
  248. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  249. procedure ScrollUp(fun:byte);
  250. var
  251.   recpack:          regpack;
  252.   ah,al,bh,bl,ch,cl,dh,dl:   byte;
  253.  
  254. begin
  255.   ah := 6;
  256.   al := fun;
  257.   bh := 15;  {attribute}
  258.   ch := StRow-1;
  259.   cl := StCol-1;
  260.   dh := EndRow;
  261.   dl := EndCol+1;
  262.   with recpack do
  263.   begin
  264.     ax := ah shl 8 + al;
  265.     bx := bh shl 8 + bl;
  266.     cx := ch shl 8 + cl;
  267.     dx := dh shl 8 + dl;
  268.   end;
  269.   intr($10,recpack);                     {call interrupt}
  270. end;
  271. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  272. procedure MovingMaze;
  273. begin
  274.   M := EndRow;
  275.   for N := StCol to EndCol do ThisRow[N] := ' ';
  276.   ScrollUp(0);
  277.   repeat
  278.     MostRows;
  279.     ScrollUp(1);
  280.   until Escape;
  281. end;
  282. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  283. Begin
  284.   initialize;
  285.   for M := StRow to (EndRow-1) do MostRows;
  286.   FinalRow;
  287.   GotoXY(1,1);
  288.   Write('Press Escape ');
  289.   repeat until Escape;
  290.   read(Kbd);
  291.   MovingMaze;
  292.   ClrScr;
  293. end.